perm filename WRTPAG.F4[RST,LCS] blob
sn#247598 filedate 1976-11-11 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE WRTPAG
C00014 ENDMK
C⊗;
SUBROUTINE WRTPAG
DATA SLSP/12.0/
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2
1 /SF/KL,RT,KP,STFSZ,NAMX /IPG/IPG
1 ,JPG,BRACK,RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(-3/4)
1 /RSP/KNM(10),ENDLN,N,NAME,NMPG,T /KBAR/KBAR(512)
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
COMMON/STF/RSTFAC(-3/4),RSTJ2 /IVV/IV(1)
COMMON /POSI/STFF(-3/4),JJ2,JPQ /LLL/L,LL,I,RXQ
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
DIMENSION ENDSTF(450),KPTR(50)
C ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
1,(R8,RQ(6)),(R9,RQ(7)),(LCNT,IV(45)),(NDPY,IV(46))
1,(LASTNM,KBAR(3)),(ENDSTF,KBAR(4)),(KPTR,KBAR(460)),(KEND,KBAR)
NMPG='PAGEA'
LB=0
CZ KEND=0
TR=LL
C TRANSPOSE? IN LL
RA=0
811 JEND=-1
METR=1000
CLEF=-99
CC J=0
JSLUR=0
LC=1
KREAD=128
SIG=CLEF
HX=2
KQ=1
KPX=1
CALL FILOUT(NAMQ,NPG)
SP=2.45
C DEFAULT VERT. SPACE UNITS
ENDSTF(1)=0
IF(N.EQ.0)GO TO 100
C SPACED OUT DEPENDING ON NUM OF LINES
HX=N
SP=SP+(HX-2.)*.11
CC100 IF(NMPG.GT.LASTNM)CALL EXIT
CC KK=1
CC I=0
100 CALL FILEIN
320 IF(TR.NE.0)CALL TRNSP(L,TR)
CALL STAVES
CZ KEND=0
CP KB=KL
JPQ=KL
NA=0
KPT=1
ENDSTF(1)=0
C LOOP STARTS HERE *******
131 NA=NA+1
CP131 DO 30 NA=KK,K
KWDS(KP)=JPQ
KP=KP+1
CC JK=KPN(NA)
CC R=Q(JK+1)
R=CODEN(KPN,NA,Q,JK)
RR=Q(JK+6)
RS=Q(JK)
IF(R.NE.5)GO TO 935
R8=-1
IF(RS.GE.6)R8=Q(JK+8)
IF(RR)GO TO 735
IF(RR.LE.Q(JK+3))RR=202.
GO TO 235
C CATCHES SLURS, TRILLS, 8VA, LINES THAT GO PAST END OF LINE.
935 IF(R.EQ.7)GO TO 835
IF(R.NE.44)GO TO 35
R=R/11.
Q(JK+1)=R
C INFOR FOR P9 AND L10 OF DASHES AND WIGGLES NOT KEPT YET!!!!!!!
IF(RR.LT.Q(JK+3))GO TO 30
C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
835 R8=0
R7=0
IF(RS.GE.6)R8=Q(JK+8)
235 IF(RR.LT.199.)GO TO 30
C P1,P2,P3,P4,P5,P6,P7,P8 ARE SAVED.
RR=-1
735 IF(RS.GE.5)R7=Q(JK+7)
ENDSTF(KPT)=6
ENDSTF(KPT+1)=R
C=Q(JK+2)
ENDSTF(KPT+2)=C
ENDSTF(KPT+3)=1
ENDSTF(KPT+4)=Q(JK+4)
ENDSTF(KPT+5)=Q(JK+5)
ENDSTF(KPT+7)=R7
ENDSTF(KPT+8)=R8
ENDSTF(KPT+6)=RR
CX A=Q(JK+6)
CX B=0
CX R7=0
CX DO 136 K=NA+1,NPX
C THIS LOOP GETS NOTE POS. OF RIGHT SIDE OF SLUR.
CX KK=KPN(K)
CX R=Q(KK+1)
CX IF(R.NE.1)GO TO 136
CX IF(C.NE.Q(KK+2))GO TO 136
CX B=B+1
CX R8=Q(KK+3)
C FIND NOTE BEFORE AND AFTER RIGHT END OF SLUR
CX IF(R8.LE.A)GO TO 336
CX ENDSTF(KPT+6)=-B+(R8-A)/(R8-R7)
C SAVE NEG. NOTE COUNT. POSITIVE WILL ALWAYS BE 12.
CX GO TO 236
CX336 R7=R8
C FIND POS OF NOTE JUST BEFORE POINT.
CX136 CONTINUE
236 KPT=KPT+13
CZ KPTR(KPT)=0
ENDSTF(KPT)=0
Q(JK+6)=202
GO TO 30
C*************
35 IF(R.NE.2)GO TO 36
IF(Q(JK).LT.6.)GO TO 30
RR=RIGHT(NA,-1)
IF(RR.GE.199.)RR=RX
Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1)-RR)/2.
C FUNCTION 'RIGHT' FINDS RIGHT ITEMS FOR CENTERING.
C CENTERS WHOLE REST
GO TO 30
36 IF(R.NE.3)GO TO 34
CLEF=CLEFN(Q,JK)
IF(IPG)GO TO 30
LL=Q(JK+2)
C GETS CLEF FOR PAGE LAYOUT
RCLEF(LL)=CLEF
GO TO 30
34 IF(R.NE.17)GO TO 37
SIG=Q(JK+5)
IF(ABS(SIG).GT.100.)SIG=-99
C DO NOT REPEAT KSIG MADE UP OF NATURALS.
CXX IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
CXX CLEF # IN P6 WITH KEY SIGS.
C NEXT CHANGES CODE NUM BACK TO ORIGINAL
37 IF(R.LT.33)GO TO 130
38 Q(JK+1)=R/11.
GO TO 30
130 IF(Q(JK+3).LT.199)GO TO 30
IF(R.NE.18)GO TO 30
KKK=K+1
R3=9
IF(SIG.NE.-99)R3=14
KK=JK
CC435 R8=0
CC R9=0
CC R10=0
435 LL=KPN(KKK)
C WDCNT,P1,P2,P3,P4,P5,P6,P7,P8
ENDSTF(KPT)=Q(KK)
ENDSTF(KPT+1)=R
ENDSTF(KPT+2)=Q(KK+2)
ENDSTF(KPT+3)=R3
CC ENDSTF(KPT+4)=Q(KK+4)
CC ENDSTF(KPT+5)=Q(KK+5)
CC ENDSTF(KPT+6)=Q(KK+6)
CC ENDSTF(KPT+7)=0
CC ENDSTF(KPT+8)=0
DO 535 JJ2=4,12
535 ENDSTF(KPT+JJ2)=Q(KK+JJ2)
KPT=KPT+13
ENDSTF(KPT)=0
RS=Q(LL+1)
IF(RS.LE.4)GO TO 30
R4=Q(LL+2)
C SAVE THE STAFF NUM. IN R4
IF(RS.NE.18)GO TO 7011
335 R3=R3+6
KK=LL
KKK=KKK+1
GO TO 435
7011 RS=CODEN(KPN,KKK+1,Q,LL)
IF(RS.LE.4)GO TO 30
IF(Q(LL+2).NE.R4)GO TO 30
IF(RS.EQ.18)GO TO 335
30 JPQ=KPN(NA+1)-KPN(NA)+JPQ
IF(NA.LT.I)GO TO 131
C END OF LOOP ****************
CALL PSHFT(I)
RS=RT
LL='J'
R4=0
R5=200
NA=L
L=KP-1
CALL PTMOVE(RN,KWDS(1))
C START LAST LOOP *******
DO 47 JJ2=1,KP
LL=KWDS(JJ2)
AA=RN(LL+1)
IF(AA.NE.10.AND.AA.NE.16)GO TO 1047
CN IF(AA.NE.10.AND.AA.NE.16)GO TO 347
DO 147 NN=JJ2+1,KP
MM=KWDS(NN)
IF(RN(MM+1).NE.16)GO TO 147
C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
IF(RN(MM).EQ.8)GO TO 47
C JUMP IF POS. IS ALREADY TAKEN CARE OF.
IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C SETS MINIMUM SPACE.
IF(RN(MM+3).LT.AA)RN(MM+3)=AA
GO TO 47
247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C CHECKS VERT. POS.
AA=RN(LL+4)+7
IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
GO TO 47
147 CONTINUE
GO TO 47
CN347 IF(AA.NE.5)GO TO 1047
C TO IMPROVE SLUR PARAMETERS
CN R8=RN(LL+8)
CN IF(RN(LL).LT.6)R8=0
CN IF(R8.GT.0)GO TO 47
C JUMP IF A BRACKET
CN R=RN(LL+6)
CN DO 647 NN=JJ2+1,KP
CN MM=KWDS(NN)
C THIS IS TO FIND SLURS AT END OF OLD LINES AND EXTEND THEM
CN IF(RN(MM+1).NE.4)GO TO 647
C FIND A BAR LINE
CN IF(RN(MM+3).GT.199.)GO TO 647
C IGNORE LAST BAR OR LINE.
CN IF(RN(MM).GT.2)GO TO 647
CN AA=ABS(RN(MM+3)-R)
CN IF(AA.GT.1.)GO TO 647
CN RN(LL+6)=R+4
CN GO TO 47
CN647 CONTINUE
CN R7=RN(LL+7)
CN R9=R-RN(LL+3)+(R8+1.)*2.
CN IF(R9.GT.7)GO TO 47
C NO WORK NEEDED. IT'S LONG ENOUGH
CN IF(RN(LL).GT.5)RN(LL+8)=-1
CN R=1.
CN IF(R7.LT.0)R=-R
CN547 RN(LL+4)=RN(LL+4)+R
CN RN(LL+5)=RN(LL+5)+R
C WERE +AA ↑↑↑↑↑
CN RN(LL+7)=R
CN GO TO 47
1047 IF(AA.NE.6)GO TO 47
IF(RN(LL).LT.7)GO TO 47
IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
47 CONTINUE
2 KWDS(KP)=JPQ
CP J=1
IF(KP.GE.250.OR.JPQ.GE.2000)TYPE 20,KP,JPQ
JJ2=KP+1
C WRITES 1 EXTRA WORD
CP JPQ=KB
DO 12 K=1,KP
CC N=KWDS(K)
CC R=RN(N+1)
R=CODEN(KWDS,K,RN,N)
IF(R.LE.2)GO TO 22
C ONCE IT FINDS A REST OR NOTE IT MUST HAVE GONE TOO FAR.
IF(R.GT.7)GO TO 12
IF(R.EQ.5)GO TO 52
IF(R.NE.4)GO TO 62
IF(RN(N).GE.4)GO TO 52
62 IF(R.NE.7)GO TO 12
52 A=RN(N+6)
C J HAS NOTE COUNT TO FIND POS OF RIGHT END OF SLUR.
IF(A.GE.0)GO TO 12
J=A
IF(J.EQ.0)J=-1
B=RN(N+2)
C B=STAFF NUM.
JJ=0
DO 32 KK=K+1,KP
CC NN=KWDS(KK)
CC A=RN(NN+1)
A=CODEN(KWDS,KK,RN,NN)
IF(A.NE.1)GO TO 32
IF(B.NE.RN(NN+2))GO TO 32
D=RN(NN+3)
JJ=JJ-1
IF(J.NE.JJ)GO TO 42
RN(N+6)=D+(D-A)*(RN(N+6)-J)
C FOUND NOTE FOR POSITION.
GO TO 12
42 A=D
32 CONTINUE
12 CONTINUE
22 CALL PUTFIL(NAMX)
LCNT=0
NDPY=0
RSTFAC(96)=0
C MUST BE 0 IN MS TO MAKE DISPLAY
CALL FASTOU(RSTFAC,128)
CALL FASTOU(KWDS,JJ2)
CALL FASTOU(RN,JPQ)
TYPE 101,NAMX
NAMX=NAMX+2
IF(IPG)GO TO 6011
NPG=NPG+1
IF(NPG.LE.MPG)GO TO 6011
NPG=1
C RESET, UPDATE FILENAMES
NAMX=NAMZ+256
NAMZ=NAMX
6011 NAMQ=NAMX
CALL FINFIL
GO TO 100
101 FORMAT(1XA5)
20 FORMAT(' TOO MUCH DATA!!! ',I3,'/250',I5,'/2000')
END